(* ===================================================================== *)
(** Application bop2vhdl : traduction d'une net-list .bop vers une net-list
    en XML
    @author Mehdi Bouaziz, Mathieu Barbin
    @version 1.0.* *)
(* ===================================================================== *)

open Inputtools
open Bop2tools

(** 
    Contrairement à bop2c, bop2xml travaille au niveau de la net-list .bop
    uniquement. Les net-list précompilée bpx ne sont pas exploitables.
    
    La raison est d'assurer une certaine cohérence entre les 2 fichiers, 
    en essayant de préserver les identifiants choisis dans le fichier .bop

    On ne fait pas de vérification de contexte dans le fichier .bop lors
    de la traduction. Il est entendu que l'utilisateur peut faire des simulations
    avec bopsimu, avant d'utiliser bop2xml
*)

(* ===================================================================== *)
(** L'implementation du module de transcription qui gere la production de code 
    des structures parsees du fichier bop vers du code XML *)
(* ===================================================================== *)
module XmlTranscriptor : Transcriptor = 
  struct
    let indent_spaces = 2

    let prod_ident prod n = 
      for i = 1 to n do
        prod (String.make indent_spaces ' ');
      done

    let line = String.make 76 '-'
  
    let init prod bopfile = 
      begin
	prod "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n";
	(* TODO : Schema ou DTD *)
        prod "\n";
        prod (Printf.sprintf "<meta_infos generator=\"bop2xml\" version=\"%s\" bopfile=\"%s\" date=\"%s\"/>\n" Message.version bopfile (Message.get_date ()));
	prod "\n";
      end 

    let rec of_expr_arith ident prod exp =
      let of_nary_operator ident prod name expl =
        prod_ident prod ident; prod (Printf.sprintf "<ope name=\"%s\">\n" name);
        List.iter (fun exp->of_expr_arith (succ ident) prod exp) expl;
        prod_ident prod ident; prod "</ope>\n";
      in
      begin
        prod_ident prod ident; prod "<arith_expr>\n";
        (
          match exp with
            | VAR name -> prod_ident prod (succ ident); prod (Printf.sprintf "<var name=\"%s\" />\n" name)
            | CST i -> prod_ident prod (succ ident); prod (Printf.sprintf "<cst val=\"%d\" />\n" i)
            | ADD(exp1, exp2) -> of_nary_operator (succ ident) prod "add" [exp1;exp2];
            | SUB(exp1, exp2) -> of_nary_operator (succ ident) prod "sub" [exp1;exp2];
            | DIV(exp1, exp2) -> of_nary_operator (succ ident) prod "div" [exp1;exp2];
            | MULT(exp1, exp2) -> of_nary_operator (succ ident) prod "mult" [exp1;exp2];
            | MOD(exp1, exp2) -> of_nary_operator (succ ident) prod "mod" [exp1;exp2];
            | EXP(exp1, exp2) -> of_nary_operator (succ ident) prod "exp" [exp1;exp2];
            | LOG(exp1) -> of_nary_operator (succ ident) prod "log" [exp1];
            | MIN(exp1, exp2) -> of_nary_operator (succ ident) prod "min" [exp1;exp2];
            | MAX(exp1, exp2) -> of_nary_operator (succ ident) prod "max" [exp1;exp2];
        );
        prod_ident prod ident; prod "</arith_expr>\n";
      end

    let of_condition_expr ident prod condexpr = 
      let rec aux ident = function
	| CONST e1 ->
	    begin
	      prod_ident prod ident; prod "<const>\n";
	      of_expr_arith (succ ident) prod e1;
	      prod_ident prod ident; prod "</const>\n";
	    end
        | COND_EQ (e1, e2) ->
            begin
              prod_ident prod ident; prod "<equal>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</equal>\n"
            end
        | COND_NEQ (e1, e2) ->
            begin
              prod_ident prod ident; prod "<not_equal>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</not_equal>\n"
            end
        | COND_PP (e1, e2) ->
            begin
              prod_ident prod ident; prod "<lesser_than>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</lesser_than>\n"
            end
        | COND_PG (e1, e2) ->
            begin
              prod_ident prod ident; prod "<greater_than>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</greater_than>\n"
            end
        | COND_SPP (e1, e2) ->
            begin
              prod_ident prod ident; prod "<strict_lesser_than>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</strict_lesser_than>\n"
            end
        | COND_SPG (e1, e2) ->
            begin
              prod_ident prod ident; prod "<strict_greater_than>\n";
              of_expr_arith (succ ident) prod e1;
              of_expr_arith (succ ident) prod e2;
              prod_ident prod ident; prod "</strict_greater_than>\n"
            end
	| COND_NEG (ce1) ->
            begin
              prod_ident prod ident; prod "<not>\n";
              aux (succ ident) ce1;
              prod_ident prod ident; prod "</not>\n"
            end
        | COND_OR (ce1, ce2) ->
            begin
              prod_ident prod ident; prod "<or>\n";
              aux (succ ident) ce1;
              aux (succ ident) ce2;
              prod_ident prod ident; prod "</or>\n"
            end
        | COND_AND (ce1, ce2) ->
            begin
              prod_ident prod ident; prod "<and>\n";
              aux (succ ident) ce1;
              aux (succ ident) ce2;
              prod_ident prod ident; prod "</and>\n"
            end
      in 
      begin
	prod_ident prod ident; prod "<cond_expr>\n";
	aux (succ ident) condexpr;
	prod_ident prod ident; prod "</cond_expr>\n"
      end 

    let of_fonctional_argument ident prod = function
      | PASSING_STYLE s -> prod_ident prod ident; prod (Printf.sprintf "<passing_style arg=\"%s\"/>" s)
      | CONSTRUCTION s -> prod_ident prod ident; prod (Printf.sprintf "<construction arg=\"%s\"/>" s) 
  
    let of_macros_declaration prod macros_decl = 
      let f_iter decl = match decl.corps_macro with
	| DefInt exp ->
            prod_ident prod 1; prod (Printf.sprintf "<defint name=\"%s\">\n" decl.nom_macro);
            of_expr_arith 2 prod exp;
            prod_ident prod 1; prod "</defint>\n";
	| DefCondInt (_if, _then, _else) ->
	    prod_ident prod 1; prod (Printf.sprintf "<defcondint name=\"%s\">\n" decl.nom_macro);
	    of_condition_expr 2 prod _if;
	    of_expr_arith 2 prod _then;
	    of_expr_arith 2 prod _else;
	    prod_ident prod 1; prod "</defcondint>\n";
	| DefString s -> prod_ident prod 1; prod (Printf.sprintf "<defstring name=\"%s\" val=\"%s\" />\n" decl.nom_macro s);
	| DefCondString (_if, _then, _else) -> 
	    prod_ident prod 1; prod (Printf.sprintf "<defcondstring name=\"%s\"/>\n" decl.nom_macro);
	    of_condition_expr 2 prod _if;
	    prod_ident prod 2; prod (Printf.sprintf "<then value=\"%s\">\n" _then);
	    prod_ident prod 2; prod (Printf.sprintf "<else value=\"%s\">\n" _else);
	    prod_ident prod 1; prod "</defcondstring>\n";
      in
      match macros_decl with
      | [] -> ()
      | _ -> 
	  begin
	    prod "<!-- Int and String Constants Declarations -->\n";
            prod "<macros_declaration>\n";
            List.iter f_iter macros_decl;
            prod "</macros_declaration>\n";
	    prod "\n";
	  end

    let of_memories_declaration prod mems_decl = 
      let f_iter dm =
	let memorytype, name =
	  match dm.type_dcl_m with
	  | RAM_decl name -> "RAM", name
	  | ROM_decl name -> "ROM", name
	in 
	begin
	  prod_ident prod 1; prod (Printf.sprintf "<memory_declaration line_dcl=\"%d\" type=\"%s\" name=\"%s\">\n" dm.ligne_dcl_m memorytype name);
          prod_ident prod 2; prod "<input_length>\n";
          of_expr_arith 3 prod dm.arite_entree_dcl_m;
          prod_ident prod 2; prod "</input_length>\n";
          prod_ident prod 2; prod "<output_length>\n";
          of_expr_arith 3 prod dm.arite_sortie_dcl_m;
          prod_ident prod 2; prod "</output_length>\n";
	  prod_ident prod 2; prod "<memory_initialisation>\n";
          begin 
	    match dm.description_entree_dcl_m with
	    | None -> ()
	    | Some mem_init ->
	        begin
		  match mem_init with
		  | Text t -> prod_ident prod 3; prod (Printf.sprintf "<of_text text=\"%s\" />\n" t);
		  | File f -> prod_ident prod 3; prod (Printf.sprintf "<of_asci_file file=\"%s\" />\n" f);
		  | BinaryFile bf -> prod_ident prod 3; prod (Printf.sprintf "<of_binaryfile file=\"%s\" />\n" bf);
		  | Counter -> Message.message#counter_for_memory dm.fichier_dcl_m; failwith "w-friendly"
		  | UnitFun _ | ArgFun _ -> Message.message#metafun_for_memory dm.fichier_dcl_m; failwith "w-friendly"
	        end
          end;
	  prod_ident prod 2; prod "</memory_initialisation>\n";
          prod_ident prod 1; prod "</memory_declaration>\n";
	end
      in 
      match mems_decl with
      | [] -> ()
      | _ ->
	  begin
	    prod "<!-- Declaration of RAM and ROM memories -->\n";
            prod "<memories_declaration>\n";
	    List.iter f_iter mems_decl;
            prod "</memories_declaration>\n";
	    prod "\n"
	  end

    let of_indexation ident prod = function
      | SegmentInit exp ->
          prod_ident prod ident; prod "<segment_init>\n";
          of_expr_arith (succ ident) prod exp;
          prod_ident prod ident; prod "</segment_init>\n";
      | Intervalle(exp1, exp2) ->
          prod_ident prod ident; prod "<interval>\n";
	  prod_ident prod (succ ident); prod "<from>\n";
          of_expr_arith (ident+2) prod exp1;
	  prod_ident prod (succ ident); prod "</from>\n";
	  prod_ident prod (succ ident); prod "<to>\n";	  
          of_expr_arith (ident+2) prod exp2;
	  prod_ident prod (succ ident); prod "</to>\n";	
          prod_ident prod ident; prod "</interval>\n";
      | Index exp ->
          prod_ident prod ident; prod "<index>\n";
          of_expr_arith (succ ident) prod exp;
          prod_ident prod ident; prod "</index>\n"

    let of_net_variable ident prod = function
      | Fresh _ -> failwith "Fresh in bop2xml ?"
      | Vecteur (ligne, nom, il) ->
          prod_ident prod ident; prod (Printf.sprintf "<vector line=\"%d\" name=\"%s\">\n" ligne nom);
          List.iter (fun i->of_indexation (succ ident) prod i) il;
          prod_ident prod ident; prod "</vector>\n";
      | Simple nom -> prod_ident prod ident; prod (Printf.sprintf "<simple name=\"%s\" />\n" nom)

    let of_string_arg_list ident prod arg_list =
      match arg_list with
      | [] -> ()
      | o ->
	  begin
	    prod_ident prod ident; prod "<string_args>\n";
	    List.iter (fun s -> prod_ident prod (ident + 2); prod (Printf.sprintf "<arg = \"%s\"/>\n" s)) arg_list;
	    prod_ident prod ident; prod "</string_args>\n";
	  end

    let of_arite_pipe_imbrique ident prod piimb = 
      prod_ident prod ident; prod "<pipe_arity>\n";
      (
	match piimb with 
	| Infere -> prod_ident prod (succ ident); prod "<infered/>\n"
	| Calcul exp -> of_expr_arith (succ ident) prod exp
	| Resultat i -> prod_ident prod (succ ident); prod (Printf.sprintf "<result value=\"%d\"/>\n" i)
      );
      prod_ident prod ident; prod "</pipe_arity>\n"

    let of_portee_noeud ident prod portee =
      prod_ident prod ident; prod "<node_type>\n";
      (
	match portee with  
	| BEBOP(nom, expl, args_fcts) -> 
            begin
              match expl, args_fcts with
              | [], [] -> prod_ident prod (succ ident); prod (Printf.sprintf "<bebop_function name=\"%s\"/>\n" nom);
              | _, _ ->
                  begin
                    prod_ident prod (succ ident); prod (Printf.sprintf "<bebop_parametric_function name=\"%s\">\n" nom);
		    (
		      match expl with
		      | [] -> ()
		      | _ ->
			  prod_ident prod (ident + 2); prod "<parameters_values>\n";
			  List.iter (of_expr_arith (ident + 3) prod) expl;
			  prod_ident prod (ident + 2); prod "</parameters_values>\n";
		    );
		    (
		      match args_fcts with
		      | [] -> ()
		      | _ -> 
			  prod_ident prod (ident + 2); prod "<functional_arguments>\n";
			  List.iter (of_fonctional_argument (ident + 3) prod) args_fcts;
			  prod_ident prod (ident + 2); prod "</functional_arguments>\n";
		    );
                    prod_ident prod (succ ident); prod "</bebop_parametric_fonction>\n"
                  end
            end
	| PIPE(nom, api) ->
            prod_ident prod (succ ident); prod (Printf.sprintf "<external_pipe name=\"%s\">\n" nom);
            of_arite_pipe_imbrique (ident + 2) prod api;
            prod_ident prod (succ ident); prod "</external_pipe>\n"
	| EXTERNAL_BLOC(nom, Some meth, arg_list, api) ->
            prod_ident prod (succ ident); prod (Printf.sprintf "<external_bloc name=\"%s\" method=\"%s\">\n" nom !meth);
	    of_string_arg_list (ident + 2) prod arg_list;
            of_arite_pipe_imbrique (ident + 2) prod api;
            prod_ident prod (succ ident); prod "</external_bloc>\n"
	| EXTERNAL_BLOC(nom, None, arg_list, api) ->
            prod_ident prod (succ ident); prod (Printf.sprintf "<external_bloc name=\"%s\">\n" nom);
	    of_string_arg_list (ident + 2) prod arg_list;
            of_arite_pipe_imbrique (ident + 2) prod api;
            prod_ident prod (succ ident); prod "</external_bloc>\n"
	      
      );
      prod_ident prod ident; prod "</node_type>\n"
    
    let rec of_imbrication ident prod = function
      | NET_VARS nvl -> 
	  begin
	    prod_ident prod ident; prod "<net_variables_list>\n";
	    List.iter (of_net_variable (succ ident) prod) nvl;
	    prod_ident prod ident; prod "</net_variables_list>\n";
	  end 
      | IMB(ligne, portee, imbl) ->
          begin
            prod_ident prod ident; prod (Printf.sprintf "<imbrication line=\"%d\">\n" ligne);
            of_portee_noeud (succ ident) prod portee;
            List.iter (of_imbrication (succ ident) prod) imbl;
            prod_ident prod ident; prod (Printf.sprintf "</imbrication>\n");
          end 

    let rec of_noeud ident prod = function
      | NOEUD(ligne, portee, imbl, nvl) -> 
          begin
            prod_ident prod ident; prod (Printf.sprintf "<node line=\"%d\">\n" ligne);
            of_portee_noeud (succ ident) prod portee;
            prod_ident prod (succ ident); prod "<input>\n";
            List.iter (of_imbrication (ident + 2) prod) imbl;
            prod_ident prod (succ ident); prod "</input>\n";
            prod_ident prod (succ ident); prod "<output>\n";
            List.iter (of_net_variable (ident + 2) prod) nvl;
            prod_ident prod (succ ident); prod "</output>\n";
            prod_ident prod ident; prod "</node>\n"
          end
      | BOUCLE_FOR(ligne, var, debut, fin, nl) ->
          begin
            prod_ident prod ident; prod (Printf.sprintf "<for_loop line=\"%d\" varname=\"%s\">\n" ligne var);
            prod_ident prod (succ ident); prod "<from>\n";
            of_expr_arith (ident + 2) prod debut;
            prod_ident prod (succ ident); prod "</from>\n";
            prod_ident prod (succ ident); prod "<to>\n";
            of_expr_arith (ident + 2) prod fin;
            prod_ident prod (succ ident); prod "</to>\n";
	    prod_ident prod (ident + 2); prod "<body_loop>\n";
            List.iter (of_noeud (ident + 3) prod) nl;
	    prod_ident prod (ident + 2); prod "</body_loop>\n";
            prod_ident prod ident; prod "</for_loop>\n";
          end
      | NOEUD_COND(ligne, cexp, nl1, nl2) -> 
          begin
            prod_ident prod ident; prod (Printf.sprintf "<if line=\"%d\">\n" ligne);
            prod_ident prod (succ ident); prod "<condition>\n";
            of_condition_expr (ident + 2) prod cexp;
            prod_ident prod (succ ident); prod "</condition>\n";
            prod_ident prod (succ ident); prod "<then>\n";
            List.iter (of_noeud (ident + 2) prod) nl1;
            prod_ident prod (succ ident); prod "</then>\n";
            prod_ident prod (succ ident); prod "<else>\n";
            List.iter (of_noeud (ident + 2) prod) nl2;
            prod_ident prod (succ ident); prod "</else>\n";
            prod_ident prod ident;  prod "</if>\n"
          end
	    
    let of_fonctions_declaration prod fcts_decl = 
      let prod_decl_entity generics fcts_args decl =
        prod_ident prod 1; prod (Printf.sprintf "<function_declaration line=\"%d\" name=\"%s\">\n" decl.ligne_dcl_f decl.nom_dcl_f);
	(
	  match generics with
	  | None | Some [] -> ()
	  | Some sl ->
              prod_ident prod 2; prod "<parameters>\n";
              List.iter (fun p-> prod_ident prod 3; prod (Printf.sprintf "<parameter name=\"%s\" />\n" p)) sl;
              prod_ident prod 2; prod "</parameters>\n";
	); 
	(
	  match fcts_args with
	  | None | Some [] -> ()
	  | Some fa ->
	      prod_ident prod 2; prod "<functional_arguments>\n";
	      List.iter (fun p -> prod_ident prod 3; prod (Printf.sprintf "<functional_argument name=\"%s\" />\n" p)) fa;
	      prod_ident prod 2; prod "</functional_arguments>\n";
	);
        prod_ident prod 2; prod "<inputs>\n";
        List.iter (of_net_variable 3 prod) decl.entrees_dcl_f;
        prod_ident prod 2; prod "</inputs>\n";
        prod_ident prod 2;prod "<outputs>\n";
        List.iter (of_net_variable 3 prod) decl.sorties_dcl_f;
        prod_ident prod 2; prod "</outputs>\n";
        prod_ident prod 2; prod "<unused>\n";
        List.iter (of_net_variable 3 prod) decl.unused_dcl_f;
        prod_ident prod 2; prod "</unused>\n";
        prod_ident prod 2; prod "<where>\n";
        List.iter (of_noeud 3 prod) decl.corps_dcl_f;
        prod_ident prod 2; prod "</where>\n";
        prod_ident prod 1; prod "</function_declaration>\n\n";
      in
      let f_iter = function    
	| PARAMETREE d -> prod_decl_entity (Some d.dp_params_formels) (Some d.dp_args_fcts_formels) d.dp_declaration
	| STANDARD decl -> prod_decl_entity None None decl
	| PARTIAL _ -> failwith "TODO, partial in bop2xml"
      in
      begin 
	prod ("<!-- Functions -->\n");
        prod "<function_declarations>\n";
	List.iter f_iter fcts_decl;
        prod "</function_declarations>\n";
      end
  end
(* ===================================================================== *)

(* ===================================================================== *)
(** Creation du module de Production du code XML *)
(* ===================================================================== *)
module XmlProducer = CodeProducer (XmlTranscriptor)
(* ===================================================================== *)


let _ = 
  Message.message#thisis "bop2xml";
  Message.message#verbose_actif;
  try
    (
      let execution = execution_of_argv Sys.argv in
      match execution.destination with
      | DestStdout    -> 
	  let prod = print_string in
	  XmlProducer.of_bopfile prod execution.source;
	  flush stdout
      | DestFile file ->
	  let oc = open_out file in
	  let prod = output_string oc in
	  XmlProducer.of_bopfile prod execution.source;
	  flush oc;
	  close_out oc
    )
  with
  | Arguments_Invalides ->
      Printf.fprintf stderr "use : %s my_file.bop > result.xml\n" Sys.argv.(0);
      Printf.fprintf stderr " or : %s my_file.bop -o result.xml\n" Sys.argv.(0);
      flush stderr
